home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / amok_lha / amok32.lha / TestBild / txt / Muster.mod < prev    next >
Text File  |  1993-08-15  |  12KB  |  385 lines
  1. (*--------------------------------------------------------------------------
  2.     :Program.      Muster.mod
  3.     :Author.       Andreas Lüdtke
  4.     :Address.      Stangestraße 11, D 2000 Hamburg 50
  5.     :Phone.        040/3905153
  6.     :History.      V1.0, 01-Jan-90, Andreas Lüdtke
  7.     :Copyright.    PD © Andreas Lüdtke 1990.
  8.     :Language.     Modula-2
  9.     :Translator.   M2Amiga 3.3d
  10.     :Contents.     Implementationsmodul mit Prozeduren zum Erzeugen
  11.     :Contents.     der Muster des Testbildprogramms
  12.  ---------------------------------------------------------------------------*)
  13.  
  14. IMPLEMENTATION MODULE Muster;
  15.  
  16. FROM SYSTEM             IMPORT ADR, FFP;
  17. FROM Graphics           IMPORT SetAPen, Draw, Move, WritePixel, RectFill,
  18.         RastPortPtr, ViewPortPtr, SetRGB4, SetRast, DrawEllipse, Text;
  19. FROM GfxMacros          IMPORT SetDrPt;
  20.  
  21.  
  22.  
  23. CONST
  24.   BaseColor     = 2;            (* geht bis BaseColor + 8       *)
  25.   LineColor     = 1;
  26.   BackColor     = 0;
  27.   TBColor       = 11;           (* Mittelgrau                   *)
  28.   G1Color       = 12;
  29.   G2Color       = 13;
  30.   GREY          = TRUE;
  31.   COLOR         = FALSE;
  32.   CFAKT1        = 1.838;        (* Korrekturfaktoren für Kreise *)
  33.   CFAKT2        = CFAKT1 / 2.0;
  34.  
  35.  
  36. PROCEDURE ChangeColors( vpptr : ViewPortPtr;
  37.                          GRAU : BOOLEAN);
  38. VAR
  39.   loop  : CARDINAL;
  40. BEGIN
  41.   IF GRAU THEN
  42.     SetRGB4( vpptr, BaseColor + 7,  0,  0,  0); (* schwarz      *)
  43.     SetRGB4( vpptr, BaseColor + 6,  3,  3,  3); (* grau         *)
  44.     SetRGB4( vpptr, BaseColor + 5,  5,  5,  5); (*  "           *)
  45.     SetRGB4( vpptr, BaseColor + 4,  7,  7,  7); (*  "           *)
  46.     SetRGB4( vpptr, BaseColor + 3,  9,  9,  9); (*  "           *)
  47.     SetRGB4( vpptr, BaseColor + 2, 11, 11, 11); (*  "           *)
  48.     SetRGB4( vpptr, BaseColor + 1, 13, 13, 13); (*  "           *)
  49.     SetRGB4( vpptr, BaseColor + 0, 15, 15, 15); (* weiß         *)
  50.   ELSE
  51.     SetRGB4( vpptr, BaseColor + 7,  0,  0,  0); (* schwarz      *)
  52.     SetRGB4( vpptr, BaseColor + 6,  0,  0, 15); (* blau         *)
  53.     SetRGB4( vpptr, BaseColor + 5, 15,  0,  0); (* rot          *)
  54.     SetRGB4( vpptr, BaseColor + 4, 15,  0, 15); (* lila         *)
  55.     SetRGB4( vpptr, BaseColor + 3,  0, 15,  0); (* grün         *)
  56.     SetRGB4( vpptr, BaseColor + 2,  4, 15, 15); (* hellblau     *)
  57.     SetRGB4( vpptr, BaseColor + 1, 15, 15,  0); (* gelb         *)
  58.     SetRGB4( vpptr, BaseColor + 0, 15, 15, 11); (* beige        *)
  59.   END;
  60. END ChangeColors;
  61.  
  62.  
  63. PROCEDURE InvertLineColors( vpptr : ViewPortPtr;
  64.                            invert : BOOLEAN);
  65. BEGIN
  66.   IF invert THEN
  67.     SetRGB4( vpptr, LineColor,  0,  0,  0);     (* schwarz      *)
  68.     SetRGB4( vpptr, BackColor, 15, 15, 15);     (* weiss        *)
  69.   ELSE
  70.     SetRGB4( vpptr, LineColor, 15, 15, 15);     (* weiss        *)
  71.     SetRGB4( vpptr, BackColor,  0,  0,  0);     (* schwarz      *)
  72.   END;
  73. END InvertLineColors;
  74.  
  75.  
  76. PROCEDURE DrawLines( rp : RastPortPtr;
  77.                   xstep : CARDINAL;
  78.                   ystep : CARDINAL);
  79. VAR
  80.   loop  : CARDINAL;
  81.   ymax  : CARDINAL;
  82. BEGIN
  83.   ymax := rp^.bitMap^.rows - 1;
  84.   SetAPen( rp, LineColor);
  85.   SetRast( rp, BackColor);
  86.   loop := xstep;
  87.   WHILE loop < 640 DO
  88.     Move( rp, loop, 0);
  89.     Draw( rp, loop, ymax);
  90.     INC(loop,xstep);
  91.   END;
  92.   loop := ystep;
  93.   WHILE loop <= ymax DO
  94.     Move( rp, 0, loop);
  95.     Draw( rp, 639, loop);
  96.     INC(loop,ystep);
  97.   END;
  98. END DrawLines;
  99.  
  100.  
  101. PROCEDURE DrawPixel( rp : RastPortPtr;
  102.                   xstep : CARDINAL;
  103.                   ystep : CARDINAL);
  104. VAR
  105.   xloop : CARDINAL;
  106.   yloop : CARDINAL;
  107.   ymax  : CARDINAL;
  108. BEGIN
  109.   ymax := rp^.bitMap^.rows - 1;
  110.   SetAPen( rp, LineColor);
  111.   SetRast( rp, BackColor);
  112.   yloop := 0;
  113.   WHILE yloop <= ymax DO
  114.     IF xstep <= 16 THEN
  115.       CASE xstep OF
  116.       | 2 : SetDrPt( rp, 0AAAAH);
  117.       | 4 : SetDrPt( rp, 08888H);
  118.       | 8 : SetDrPt( rp, 08080H);
  119.       | 16: SetDrPt( rp, 08000H);
  120.       END;
  121.       Move( rp, 0, yloop);
  122.       Draw( rp, 639, yloop);
  123.     ELSE
  124.       xloop := 0;
  125.       WHILE xloop < 640 DO
  126.         IF WritePixel( rp, xloop, yloop) THEN END;
  127.         INC(xloop,xstep);
  128.       END;
  129.     END;
  130.     IF (ystep>8) AND WritePixel( rp, 639, yloop) THEN END;
  131.     INC(yloop,ystep);
  132.   END;
  133.   xloop := 0;
  134.   WHILE xloop < 640 DO  (* für die unterste Zeile       *)
  135.     IF WritePixel( rp, xloop, ymax) THEN END;
  136.     INC(xloop,xstep);
  137.   END;
  138.   IF (ystep>8) AND WritePixel( rp, 639, ymax) THEN END;
  139.   SetDrPt( rp, 0FFFFH);
  140. END DrawPixel;
  141.  
  142.  
  143. PROCEDURE DrawSquares( rp : RastPortPtr;
  144.                     xstep : CARDINAL;
  145.                     ystep : CARDINAL);
  146. VAR
  147.   xloop : CARDINAL;
  148.   yloop : CARDINAL;
  149.   ymax  : CARDINAL;
  150.   Pt1   : CARDINAL;
  151.   Pt2   : CARDINAL;
  152. BEGIN
  153.   ymax := rp^.bitMap^.rows - 1;
  154.   SetAPen( rp, LineColor);
  155.   SetRast( rp, BackColor);
  156.   yloop := 0;
  157.   WHILE yloop < ymax DO
  158.     IF xstep <= 8 THEN
  159.       CASE xstep OF
  160.       | 2 : Pt1 := 0CCCCH;      Pt2 := 03333H;
  161.       | 4 : Pt1 := 0F0F0H;      Pt2 := 00F0FH;
  162.       | 8 : Pt1 := 0FF00H;      Pt2 := 000FFH;
  163.       END;
  164.       xloop := 0;
  165.       SetDrPt( rp, Pt1);
  166.       WHILE xloop < ystep DO
  167.         Move( rp, 0, yloop+xloop);
  168.         Draw( rp, 639, yloop+xloop);
  169.         INC(xloop);
  170.       END;
  171.       xloop := ystep;
  172.       SetDrPt( rp, Pt2);
  173.       WHILE xloop < 2*ystep DO
  174.         Move( rp, 0, yloop+xloop);
  175.         Draw( rp, 639, yloop+xloop);
  176.         INC(xloop);
  177.       END;
  178.     ELSE
  179.       xloop := 0;
  180.       WHILE xloop <= 640 DO
  181.         RectFill(rp,xloop,yloop,xloop+xstep-1,yloop+ystep-1);
  182.         RectFill(rp,xloop+xstep,yloop+ystep,xloop+2*xstep-1,yloop+2*ystep-1);
  183.         INC(xloop,2*xstep);
  184.       END;
  185.     END;
  186.     INC(yloop,2*ystep);
  187.   END;
  188.   SetDrPt( rp, 0FFFFH);
  189. END DrawSquares;
  190.  
  191.  
  192. PROCEDURE DrawSteps( rp : RastPortPtr);
  193. VAR
  194.   loop  : CARDINAL;
  195.   ymax  : CARDINAL;
  196. BEGIN
  197.   ymax := rp^.bitMap^.rows - 1;
  198.   FOR loop := 0 TO 7 DO
  199.     SetAPen( rp, BaseColor + loop);
  200.     RectFill( rp, loop*80, 0, (loop*80) + 79, ymax);
  201.   END;
  202. END DrawSteps;
  203.  
  204.  
  205. PROCEDURE DrawRects( rp : RastPortPtr;
  206.                   xstep : CARDINAL;
  207.                   ystep : CARDINAL);
  208. VAR
  209.   count : CARDINAL;
  210.   xloop : CARDINAL;
  211.   yloop : CARDINAL;
  212.   ymax  : CARDINAL;
  213. BEGIN
  214.   ymax := rp^.bitMap^.rows - 1;
  215.   SetAPen( rp, LineColor);
  216.   SetRast( rp, BackColor);
  217.   count := 1;
  218.   yloop := (ymax DIV 2) +ystep;
  219.   xloop := 320 + xstep;
  220.   WHILE (yloop < ymax) AND (xloop < 640) DO
  221.     Move( rp, xloop, yloop);
  222.     Draw( rp, xloop-2*count*xstep, yloop);
  223.     Draw( rp, xloop-2*count*xstep, yloop-2*count*ystep);
  224.     Draw( rp, xloop, yloop-2*count*ystep);
  225.     Draw( rp, xloop, yloop);
  226.     INC(count);
  227.     INC(xloop,xstep);
  228.     INC(yloop,ystep);
  229.   END;
  230. END DrawRects;
  231.  
  232.  
  233. PROCEDURE DrawCircles( rp : RastPortPtr;
  234.                     xstep : CARDINAL);
  235. VAR
  236.   xloop : CARDINAL;
  237. BEGIN
  238.   xloop := xstep;
  239.   SetAPen( rp, LineColor);
  240.   SetRast( rp, BackColor);
  241.   IF WritePixel( rp, 320, rp^.bitMap^.rows DIV 2) THEN END;
  242.   IF rp^.bitMap^.rows > 256 THEN
  243.     WHILE xloop < 256 DO
  244.       DrawEllipse( rp, 320, 256, CARDINAL(CFAKT2*FFP(xloop)), xloop);
  245.       INC(xloop,xstep);
  246.     END;
  247.   ELSE
  248.     WHILE xloop < 128 DO
  249.       DrawEllipse( rp, 320, 128, CARDINAL(CFAKT1*FFP(xloop)), xloop);
  250.       INC(xloop,xstep);
  251.     END;
  252.   END;
  253. END DrawCircles;
  254.  
  255.  
  256. PROCEDURE DrawPicture( rp : RastPortPtr);
  257. CONST
  258.   rab   = 432;                  (* Breite Rechteck                      *)
  259.   xra   = (640-rab) DIV 2;      (* X-Offset Rechteck                    *)
  260.   ftb   = rab DIV 8;            (* Breite einer Farbtreppe              *)
  261.   gtb   = rab DIV 4;            (* Breite einer Grautreppe              *)
  262.   xstep = 32;                   (* Hintergrundrasterbreite              *)
  263. VAR
  264.   loop  : CARDINAL;             (* Schleifenvariable                    *)
  265.   ymax  : CARDINAL;             (* maximale Bildschirmhoehe-1           *)
  266.   rah   : CARDINAL;             (* Höhe Rechteck                        *)
  267.   yra   : CARDINAL;             (* Y-Offset Rechteck                    *)
  268.   fth   : CARDINAL;             (* Höhe Farbtreppe                      *)
  269.   gth   : CARDINAL;             (* Höhe Grautreppe                      *)
  270.   gto   : CARDINAL;             (* Offset Grautreppe                    *)
  271.   mto   : CARDINAL;             (* Mittenoffset                         *)
  272.   mth   : CARDINAL;             (* Höhe Mittentreppe                    *)
  273.   lth   : CARDINAL;             (* Höhe Rasterstriche                   *)
  274.   lto   : CARDINAL;             (* Rasteroffset                         *)
  275.   wth   : CARDINAL;             (* Höhe Weißetreppe                     *)
  276.   wto   : CARDINAL;             (* Rasteroffset                         *)
  277.   cto   : CARDINAL;             (* Farbbalkenoffset                     *)
  278.   ystep : CARDINAL;             (* Hintergrundrasterhöhe                *)
  279. BEGIN
  280.   ymax  := rp^.bitMap^.rows;
  281.   rah           := 214;         fth             := 64;
  282.   gth           := 35;          mth             := 20;
  283.   lth           := 27;          wth             := 10;
  284.   ystep         := 16;
  285.   IF rp^.bitMap^.rows > 256 THEN
  286.     rah         := 2*rah;       fth             := 2*fth;
  287.     gth         := 2*gth;       mth             := 2*mth;
  288.     lth         := 2*lth;       wth             := 2*wth;
  289.     ystep       := 2*ystep;
  290.   END;
  291.   yra   := (ymax-rah) DIV 2;
  292.   gto   := yra+fth;
  293.   mto   := gto+gth;
  294.   lto   := mto+mth;
  295.   wto   := lto+lth;
  296.   cto   := wto+wth;
  297. (* Hier wird das Hintergrundraster gezeichnet   *)
  298.   SetAPen( rp, LineColor);
  299.   SetRast( rp, TBColor);
  300.   loop := xstep;
  301.   WHILE loop < 640 DO
  302.     Move( rp, loop, 0);
  303.     Draw( rp, loop, ymax);
  304.     INC(loop,xstep);
  305.   END;
  306.   loop := ystep;
  307.   WHILE loop <= ymax DO
  308.     Move( rp, 0, loop);
  309.     Draw( rp, 639, loop);
  310.     INC(loop,ystep);
  311.   END;
  312. (* Hier wird die Farbtreppe gezeichnet  *)
  313.   RectFill( rp, xra, yra, xra+rab-1, yra+rah);
  314.   FOR loop := 0 TO 7 DO
  315.     SetAPen( rp, BaseColor + loop);
  316.     RectFill( rp, xra+loop*ftb, yra, xra+ftb-1+(loop*ftb), yra+fth-1);
  317.   END;
  318. (* Jetzt kommt die Grautreppe   *)
  319.   SetAPen( rp, BackColor);
  320.   RectFill( rp, xra+0*gtb, gto, xra+gtb-1+(0*gtb), gto+gth-1);
  321.   SetAPen( rp, G1Color);
  322.   RectFill( rp, xra+1*gtb, gto, xra+gtb-1+(1*gtb), gto+gth-1);
  323.   SetAPen( rp, G2Color);
  324.   RectFill( rp, xra+2*gtb, gto, xra+gtb-1+(2*gtb), gto+gth-1);
  325. (* und hier der 2 Pixel breite weiße Strich     *)
  326.   SetAPen( rp, LineColor);
  327.   Move( rp, 319, gto);
  328.   Draw( rp, 319, gto+gth-1);
  329.   Move( rp, 320, gto);
  330.   Draw( rp, 320, gto+gth-1);
  331. (* und nun der schwarze Balken in der Mitte     *)
  332.   SetAPen( rp, BackColor);
  333.   RectFill( rp, xra+77, mto, 639-xra-77, mto+mth-1);
  334. (* und jetzt die schwarzen Strichmuster         *)
  335.   loop := xra+16;
  336.   WHILE loop < xra+gtb DO
  337.     Move( rp, loop, lto);
  338.     Draw( rp, loop, lto+lth-1);
  339.     INC( loop, 16);
  340.   END;
  341.   loop := xra+gtb+8;
  342.   WHILE loop < xra+2*gtb DO
  343.     Move( rp, loop, lto);
  344.     Draw( rp, loop, lto+lth-1);
  345.     INC( loop, 8);
  346.   END;
  347.   loop := xra+2*gtb+4;
  348.   WHILE loop < xra+3*gtb DO
  349.     Move( rp, loop, lto);
  350.     Draw( rp, loop, lto+lth-1);
  351.     INC( loop, 4);
  352.   END;
  353.   loop := xra+3*gtb+2;
  354.   WHILE loop < xra+4*gtb DO
  355.     Move( rp, loop, lto);
  356.     Draw( rp, loop, lto+lth-1);
  357.     INC( loop, 2);
  358.   END;
  359. (* und hier der 2 Pixel breite schwarze Strich  *)
  360.   Move( rp, 319, wto);
  361.   Draw( rp, 319, wto+wth-1);
  362.   Move( rp, 320, wto);
  363.   Draw( rp, 320, wto+wth-1);
  364. (* und nun noch die bunten Balken       *)
  365.   SetAPen( rp, BaseColor+5);
  366.   RectFill( rp, xra, cto, xra+rab-150, cto-1+(yra+rah-cto) DIV 2);
  367.   SetAPen( rp, BaseColor+3);
  368.   RectFill( rp, xra, cto+(yra+rah-cto) DIV 2, xra+rab-150, yra+rah);
  369.   SetAPen( rp, BaseColor+6);
  370.   RectFill( rp, xra+rab-150, cto, 639-xra, yra+rah);
  371. (* zum Schluss noch den Kreis und den Text      *)
  372.   SetAPen( rp, LineColor);
  373.   IF ymax > 256 THEN
  374.     DrawEllipse( rp, 320, (ymax+1) DIV 2, CARDINAL(CFAKT2*FFP((ymax-1) DIV 2)),
  375.       (ymax-1) DIV 2);
  376.   ELSE
  377.     DrawEllipse( rp, 320, (ymax+1) DIV 2, CARDINAL(CFAKT1*FFP((ymax-1) DIV 2)),
  378.       (ymax-1) DIV 2);
  379.   END;
  380.   Move( rp, xra+125, mto+(mth DIV 2)+2);
  381.   Text( rp, ADR("AMIGA Testbildgenerator"), 23);
  382. END DrawPicture;
  383.  
  384. END Muster.
  385.